Shareware Grab Bag/Shareware Grab Bag.iso/007/qbfe10.arc/EDITFLD.BAS

BASIC Source File | 1987-11-27 | 20KB | 389 lines

'                              EditField
'
'                                V1.0
'
'                     (C) 1987 By Tony Elliott
'
'            A Multi-purpose Field Editor for QuickBASIC V4.0
'
'        Please refer any comments or suggestions to the QuickBASIC
'      Conference at Programmer's Information Exchange [phone]
'
'
'
'EDITFLD.BAS  Module Level Code

DEFINT A-Z
COMMON SHARED /editfld/ row, col, ucase, minval!, maxval!, justify, padchar, keystat, kfg, kbg, krow, kcol, sfg, sbg, dfg, dbg, insmode, nul, Alarm

SUB EditField (old$, ed$, format$, retflag%) STATIC

Initialize:
    retflag = 0                                     'Reset condition flag from previous calls
    ed$ = old$                                      'Make old$ the string to edit
    comp$ = old$                                    'Keep an original copy (before case conversions)
    fldlen = LEN(format$)                           'Set fldlen to the length of format$.
    IF insmode <> 0 THEN                            'If insert mode is on then
        insert = -1                                 'change value for call to setkbd.
        LOCATE , , , 1, 7                           'Change cursor to block
    ELSE                                            'If insert is off then
        insert = 0                                  'change variable for call
        LOCATE , , , 6, 7                           'and change cursor to flat line.
    END IF
    CALL setkbd(insert, 0, 0, 0)                    'Set insert mode.

                                                           'Set Defaults
    IF row = 0 AND col = 0 THEN row = CSRLIN: col = POS(0) 'Use current cursor location.
    IF sfg = 0 AND sbg = 0 THEN sfg = 0: sbg = 7           'and background colors.
    IF dfg = 0 AND dbg = 0 THEN dfg = 7: dbg = 0           'when exiting the routine.
    IF padchar = 0 THEN padchar = 32
    IF (krow = 0 AND kcol = 0) OR (kfg = 0 AND kbg = 0) THEN keystat = 0  'For keystat, turn it off.

    GOSUB ChangeCase                                'Makes initial case conversion / UPCASE flag
    fieldreset = 0                                  'Use sfg,sbg colors
    IF LEFT$(format$, 1) = "\" THEN                 'Checks the type of data to be
        ftype = 1                                   'input.
    END IF
                                                    'If ftype=1 then it is a text field
    IF LEFT$(format$, 1) = "#" THEN                 'If ftype=2 then it is a numeric field
        ftype = 2
        IF ucase <> 0 THEN insert = -1
        IF VAL(old$) = 0 THEN                       'Make sure that no string data was
            old$ = ""                               'accidently passed in old$
            comp$ = ""
        ELSE
            old$ = STR$(VAL(old$))                  'If numeric mode, make sure a numeric
            comp$ = old$                            'VALUE (not alphabetic characters)
        END IF                                      'was passed in old$.
        IF maxval! = 0 THEN                         'If no value was supplied for maxval!,
            decloc = INSTR(format$, ".")            'find the location of the decimal.
            IF decloc = 0 THEN                      'If no decimal, then set maxval! to
                maxval! = 10 ^ LEN(format$) - 1     '10 to the power of the number of digits
            ELSE                                    'in format$ minus 1, or if there is a decimal,
                maxval! = 10 ^ (decloc - 1) - 1     'to the power of the number of digits to the
            END IF                                  'left of the decimal minus 1.
        END IF
    END IF

    IF ftype = 0 THEN                               'If format$ was invalid
        stat$ = "** Invalid FORMAT$ !  Cannot Process field! **"
        CALL StatLine(stat$, stat)                  'Display stat$ on line 25
        GOSUB Alarm                                 'Sound alarm
        retflag = 99                                'Set flag to indicate error.
        GOSUB ResetVar                              'Reset argument variables
        EXIT SUB                                    'Exit subprogram
    END IF
    GOSUB FormatField                               'Display field in required format.

Position:
    GOSUB DisplayField                              'Display field contents in selected colors
                                                    'and format.
Strobe:
    inp$ = INKEY$                                   'Strobe keyboard for input
    GOSUB DisplayStatus                             'display INS, CAPS & NUM Lock status
    IF inp$ = "" THEN GOTO Strobe                   'Nothing here, try again.

    IF stat = 1 THEN                                'If there is a message on the status
        CALL StatLine("", stat)                     'line... turn it off.
    END IF

    IF LEN(inp$) = 2 THEN GOTO ExtendedKeys         'Check to see if extended key was pressed

    char = ASC(inp$)                                'It's easier to work with numbers using CASE.
    SELECT CASE char                                'Checks for standard characters
        CASE 13                                     'Check for return.
            GOTO ExitSub

        CASE 27                                     'check for ESC key.  If pressed once and
            IF ftype = 1 THEN                       'the field has been changed from its
                IF comp$ <> ed$ AND abort = 0 THEN  'original value, the original value will
                    ed$ = old$                      'be restored.  If pressed a second time,
                    curpos = LEN(ed$): abort = -1   'the routine will be exited and an abort
                    GOTO Position                   'flag will be set.
                ELSE
                    retflag = 1                     'Set retflag to indicating an abort,
                    GOSUB FormatField               'Reset the field display,
                    GOSUB ResetVar                  'reset argument variables and
                    EXIT SUB                        'exit the routine.
                END IF
            ELSE
                firstnum = 0
                IF VAL(old$) <> VAL(ed$) THEN       'This handles "numeric only" data if the
                    IF VAL(old$) > 0 THEN           'ESC was pressed
                        ed$ = old$                  'Restore original value
                        GOSUB FormatField           'Use special numeric formatting.
                        GOTO Position               'Go back and display field.
                    ELSE
                        LOCATE row, col             'If nothing was passed in old$,
                        PRINT SPC(fldlen);          'and no current value, erase the
                        GOTO Position               'field.
                    END IF
                ELSE
                    retflag = 1                     'ESC was pressed a second consecutive
                    GOSUB FormatField               'time. Set retflag to indicate an "abort",
                    GOSUB ResetVar                  'reset argument variables
                    EXIT SUB                        'and exit the routine.
                END IF
            END IF

        CASE 8                                      'Check for backspace key.
            IF LEN(ed$) = 0 OR curpos = 0 THEN      'If on an empty field...
                GOSUB Alarm                         'sound alarm and go back for
                GOTO Strobe                         'more input.
            END IF
            IF LEN(ed$) > 1 THEN                    'If ed$ is longer than one character then
            ed$ = LEFT$(ed$, curpos - 1) + RIGHT$(ed$, LEN(ed$) - (curpos))
                curpos = curpos - 1                 'Move cursor to left one character.
            ELSE
                ed$ = ""                            'If ed$ is one character long then
                curpos = 0                          'erase it and reset the cursor position.
            END IF

        CASE ELSE                                   'If any other key was pressed
        IF ftype = 1 THEN                           'and in the text entry mode, check
            IF ASC(inp$) < 32 OR ASC(inp$) > 128 THEN 'if character is standard alphabetic.
                GOSUB Alarm                         'Nope! Sound bell and display a message
                stat$ = "** Invalid Character! **"  'on line 25.
                CALL StatLine(stat$, stat)
                GOTO Strobe                         'Go back and try again
            ELSE
                GOSUB ChangeCase                    'Character passed test.. Now make the
            END IF                                  'proper case conversion.
        ELSE
            IF ASC(inp$) <> 46 AND (ASC(inp$) < 48 OR ASC(inp$) > 57) THEN                           '0-9 and "." (decimal).
                GOSUB Alarm                                 'Uh oh.. Gotcha
                stat$ = "Only Numeric Input is Allowed!"    'Sound the bell and display the
                CALL StatLine(stat$, stat)          'status message on line 25.
                GOTO Strobe                         'Go back and try again.
            END IF
            IF ucase <> 0 AND firstnum = 0 THEN     'If in the numeric mode and ucase
                ed$ = inp$                          'is non-zero and a key has not been
                firstnum = 1                        'pressed since the routine has been
                curpos = 1                          'called, clear the field, set ed$ to
                GOSUB DisplayField                  'the key pressed, set the cursor to the
                GOTO Strobe                         'begin
            END IF
        END IF

        IF LEN(ed$) = fldlen AND (insert OR curpos = fldlen) THEN 'Is the field at its maximum
            GOSUB Alarm                                         'length? Yes, sound bell
            stat$ = "** String is at Maximum Length! **"        'display status message
            CALL StatLine(stat$, stat)
            GOTO Strobe                             'Go back and try again
        END IF

        IF insert THEN                              'In the insert mode, add inp$ at cursor position moving
            ed$ = LEFT$(ed$, curpos) + inp$ + RIGHT$(ed$, LEN(ed$) - (curpos)) 'everthing to the right of the cursor
        ELSE                                        'to the right one space.
            IF curpos = LEN(ed$) THEN               'If at the end of the field and in the
                ed$ = ed$ + inp$                    'overwrite mode, add inp$ to the end of
            ELSE                                    'ed$.
                MID$(ed$, curpos + 1) = inp$        'If not at the end of the field, replace
            END IF                                  'character at the cursor's position with
        END IF                                      'inp$.
        curpos = curpos + 1                         'Move over one space.
        IF curpos = fldlen THEN                     'If cursor is past the end of the field
            curpos = fldlen - 1                     'move it back.
        END IF
    END SELECT
    abort = 0                                       'Reset the ESC flag
    GOTO Position


ExtendedKeys:                                       'Process the Extended Keys
    exkey = ASC(RIGHT$(inp$, 1))                    'Put extended key code in exkey.
    SELECT CASE exkey
        CASE 83                                     'Delete Key -- Deletes character at
            IF curpos < LEN(ed$) THEN               'cursor position.
                ed$ = LEFT$(ed$, curpos) + RIGHT$(ed$, LEN(ed$) - (curpos + 1))
            ELSE                                    'If cursor is not inside the field
                GOSUB Alarm                         'then sound bell.
            END IF

        CASE 75                                     'Left Arrow -- Cursor left one
            curpos = curpos - 1                     'character. Stop at first character
            IF curpos < 0 THEN curpos = 0           'in field

        CASE 77                                     'Cursor-Right
            IF curpos < LEN(ed$) AND curpos < fldlen - 1 THEN  'Don't move past the right end of the
                curpos = curpos + 1                 'current string or outside of the defined field
            END IF

        CASE 82                                     'Insert Key.  Acutal changing of the
            IF insert THEN                          'If insert is on
                LOCATE , , , 1, 7                   'change cursor to a block.
            ELSE                                    'if not,
                LOCATE , , , 6, 7                   'change it to a flat line
            END IF

        CASE 71                                     'Home Key -- Position cursor on
            curpos = 0                              'first character in field.

        CASE 79                                     'End Key -- Cursor to last
             curpos = LEN(ed$)                      'character in field.
             IF curpos = fldlen THEN                'Don't let cursor go ouside
                curpos = fldlen - 1                 'of the field
             END IF

        CASE 119                                    'Ctrl-Home -- Deletes contents of
            ed$ = ""                                'current field.
            curpos = 0

        CASE 116                                    'Ctrl-Cursor Right - Move cursor to the
            wordloc = INSTR(curpos + 1, ed$, " ")   'right one word.
            IF wordloc > 0 THEN curpos = wordloc    'Space is the only valid delimeter.

        CASE 115                                    'Ctrl-Left Arrow - Word Left.
            FOR char = curpos TO 1 STEP -1          'Start looking for a space from the current
                word$ = MID$(ed$, char, 1)          'cursor position to the beginning of the field.
                IF word$ = " " AND char < curpos THEN 'If found, the position is flagged in the
                    EXIT FOR                        '"char" variable.  Exit the FOR loop.
                END IF                              'If not found, try the next character.
            NEXT char                               'Position cursor at flagged location.  If nothing
            curpos = char                           'was found, it will be at the beginning of the field.

        CASE 117                                    'Cntrl-End -Clear from cursor to end of field
            ed$ = LEFT$(ed$, curpos)                'Left trunctuate ed$ at cursor position
            GOSUB DisplayField                      'Redisplay field

        CASE ELSE                                   'If any other extended key was pressed,
            retflag = exkey                         'return its code in retflag.
            GOTO ExitSub                            'This is signal to exit the routine.

     END SELECT
     GOTO Position


ExitSub:
    IF nul <> 0 AND ((ftype = 1 AND ed$ = "") OR (ftype = 2 AND VAL(ed$) = 0)) THEN
        stat$ = "*** An Entry is Required.  Press ESC to Abort ***"
        CALL StatLine(stat$, stat)                  'If ed$ is nul and it is not allowed,
        GOSUB Alarm                                 'display a message, sound the bell and
        GOTO Position                               'return for input.
    END IF

    IF ftype = 2 THEN
        IF (VAL(ed$) > maxval! OR VAL(ed$) < minval!) THEN
            stat$ = "*** Acceptable Values are" + STR$(minval!) + " -" + STR$(maxval!) + ". Please Re-enter. ***"
            CALL StatLine(stat$, stat)              'If value of ed$<minval! or >maxval! then
            GOSUB Alarm                             'sound the bell..
            ed$ = old$                              'restore ed$ to the original value
            GOSUB FormatField                       'Re-display the original value in the
            GOTO Position                           'correct format and begin again.
        END IF
    END IF
    fieldreset = 1                                  'Display field using dfg,dbg colors.
    GOSUB FormatField                               'Retrieve the formatted output.
    IF ftype = 1 THEN                               'If in the text entry mode, format the text
        SELECT CASE justify                         'obeying the justify argument.
            CASE 1                                  'Left Justify
                ed$ = LEFT$(ed$ + STRING$(fldlen, 32), fldlen)

            CASE 2                                  'Right justify
                ed$ = RIGHT$(STRING$(fldlen, 32) + ed$, fldlen)

            CASE 3                                    'Center text within the width of
                IF LEN(ed$) < fldlen - 2 THEN         'format$.  Length must be at
                    temp$ = STRING$(fldlen, 32)       'least 2 characters less than
                    fldpos = (fldlen - LEN(ed$)) / 2  'format$.
                    MID$(temp$, fldpos, LEN(ed$)) = ed$
                    ed$ = temp$
                END IF

            CASE ELSE                               'If zero or anything else, do nothing.
         END SELECT
         GOSUB FormatField                          'Re-display the formatted field
    ELSE
        IF justify <> 0 THEN                        'If in the numeric mode an justify is
            ed$ = STR$(VAL(ed$))                    'set to a non-zero, remove the
        END IF                                      'print using format from ed$.
    END IF
    GOSUB ResetVar                                  'Reset argument variables
    EXIT SUB                                        'Bye-bye

DisplayField:
    GOSUB ChangeCase                                'Make case conversion.
    COLOR sfg, sbg                                  'Use "selected" colors
    LOCATE row, col, 0                              'Position cursor
    IF ftype = 1 THEN                               'Text print routine
        PRINT USING format$; ed$ + STRING$(fldlen, padchar);
        LOCATE row, col + LEN(ed$)
    ELSE
        PRINT LEFT$(ed$ + STRING$(fldlen, 32), fldlen)'Numeric print routine
    END IF
    LOCATE row, col + curpos, 1
RETURN

FormatField:
    num$ = ""
    LOCATE row, col, 0                              'Position cursor & turn off
    GOSUB ChangeCase                                'Change to proper case
     IF fieldreset = 1 OR retflag = 1 THEN          'Set color based on FIELDRESET.
        COLOR dfg, dbg                              'IF 1 then the routine is preparing
     ELSE                                           'exit, and if 0 the routine is
        COLOR sfg, sbg                              'initializing.
     END IF
     IF ftype = 1 THEN                              'Display text using format$
        PRINT USING format$; ed$
     ELSE
        IF VAL(ed$) = 0 THEN                        'If ed$ has no numeric value then just
            PRINT SPC(fldlen);                      'print spaces on the screen so entering
            num$ = " "                              'new data is easier.
        ELSE
            PRINT USING format$; VAL(ed$)           'Print numeric data using format$.
            IF num$ = "" THEN
                FOR char = col TO col + fldlen - 1  'Read formated numeric display
                    num$ = num$ + CHR$(SCREEN(row, char)) 'from screen into num$ for proper
                NEXT char                           'on screen editing
                ed$ = num$                          'Assign ed$ with data retrieved from
            END IF                                  'display.
        END IF
     END IF
     IF insmode THEN                                'If insert is on, position cursor at beginning
        curpos = 0                                  'of field.  If off, position cursor at end
     ELSE                                           'of field (personal preference).
        curpos = LEN(ed$)
        IF curpos = fldlen THEN                     'Don't let cursor wander outside
            curpos = fldlen - 1                     'of the field
        END IF
     END IF
     LOCATE , , 1                                   'Make sure cursor is on.
RETURN

ChangeCase:
    IF ucase = 1 THEN                               'Convert to upper case
        ed$ = UCASE$(ed$)
        inp$ = UCASE$(inp$)
        comp$ = UCASE$(comp$)
    ELSEIF ucase = 2 THEN                           'Convert to lower case
        ed$ = LCASE$(ed$)
        inp$ = LCASE$(inp$)
        comp$ = LCASE$(comp$)
    END IF
RETURN

DisplayStatus:
    kstat$ = ""                                         'Nul the Keyboard status $
    CALL GetKbd(insert, caps, numlk, scrl)              'Get keyboard status.
    IF keystat = 0 THEN RETURN                          'If keystat is off, return
    IF insert THEN kstat$ = "INS" ELSE kstat$ = "OVW"   'Create the key status display.
    IF caps THEN kstat$ = kstat$ + "CAP" ELSE kstat$ = kstat$ + "   "
    IF numlk THEN kstat$ = kstat$ + "NUM" ELSE kstat$ = kstat$ + "   "
    CALL CalcAttr(kfg, kbg, attr)                       'Calculate the color attribute. (ADVBAS or PROBAS)
    CALL XqPrint(kstat$, krow, kcol, attr, 0)           'Display it. (ADVBAS)
   'CALL XqPrint(kstat$, krow, kcol, attr, 0, 0)        'Display it (PROBAS)
RETURN

ResetVar:
    row = 0: col = 0                                    'Reset variables for routine
RETURN                                                  'exit.

Alarm:
    IF noise = 0 THEN                                   'Sound of error alarm .. Change to
        BEEP                                            'SOUND 1000,1:SOUND 1500,1:SOUND 1000,1
    END IF                                              'if you don't like the regular ole "BEEP"
RETURN

END SUB